(defun pimac () ''/π)
(declare (read))
(setsyntax '/π 'macro (function pimac))
(declare (sstatus macro /π '(lambda () ((lambda (/π) (eval /π) /π) (read)))) )

π
(defun qexpander (m sharep)
       (prog (x y)
	     (cond ((atom m) (return (list 'quote m)))
		   ((eq (car m) '/,) (return (cdr m)))
		   ((and (not (atom (car m)))
			 (eq (caar m) '/,/@))
		    (return (list 'append (cdar m) (qexpander (cdr m) sharep)))))
	     (setq x (qexpander (car m) sharep)
		   y (qexpander (cdr m) sharep))
	     (and sharep
		  (not (atom x))
		  (not (atom y))
		  (eq (car x) 'quote)
		  (eq (car y) 'quote)
		  (eq (cadr x) (car m))
		  (eq (cadr y) (cdr m))
		  (return (list 'quote m)))
	     (and (atom y) (return (list 'cons x y)))
	     (and (eq (car y) 'list)
		  (return (cons 'list (cons x (cdr y)))))
	     (and (eq (car y) 'quote)
		  (null (cadr y))
		  (return (list 'list x)))
	     (return (list 'cons x y))))

π(defun qmac ()
	((lambda (c)
		 (cond ((= c 41) (tyi) (qexpander (read) t))
		       (t (qexpander (read) nil))))
	 (tyipeek)))

π(defun cmac ()
	((lambda (ch)
		 (cond ((= ch 100) (tyi) (cons '/,/@ (read)))
		       (t (cons '/, (read)))))
	 (tyipeek)))

π(setsyntax '/` 'macro (function qmac))
π(setsyntax '/, 'macro (function cmac))

;;; (TOJHAK code) => (dest1 dest2 ...)
;;; where dest is one of:
;;;	(RT overhead regs opcode op1 op2)
;;;	(TEMP overhead regs opcode op1 op2)
;;;	(VAR overhead regs opcode op1 op2)
;;;	(RTREF overhead regs base op1)		;op1 is an RT dest
;;;	(REGREF overhead regs base op1)		;op1 is a VAR or TEMP dest
;;; overhead = number of moves
;;; regs = registers used in the calculation EXCLUSIVE of the final destination:
;;; 		0 (none), 1 (RTA or RTB), 2 (RTA), 3 (RTA and RTB)
;;; opcode = a machine opcode, or CONSTANT, or VARIABLE
;;; When a dest is embedded in another dest, the desttype RT may eventually
;;; be replaced by RTA or RTB.  It may also remain as is for the code linearizer.

;;; As a general heuristic, it is never worth increasing the overhead
;;; unless you have no choice, or unless it reduces the usage of RT registers
;;; locally.  (The routine SIFTCODE makes more global decisions at each step.)

(defun tojhak (code)
       (cond ((atom code)
	      (list (list 'VAR 0 0
			  (cond ((numberp code) 'CONSTANT) (t 'VARIABLE))
			  code)))
	     (t (caseq (car code)
		       ((+ * // \ +$ *$ //$)
			(tojbinary (caseq (car code)
					  ((+) 'ADD)
					  ((*) 'MULT)
					  ((//) 'QUO)
					  ((\) 'REM)
					  ((+$) 'FADD)
					  ((*$) 'FMULT)
					  ((//$) 'FDIV))
				   (cadr code)
				   (caddr code)))
		       ((ABS FIX FLOAT 1+ 1-)
			(tojunary (caseq (car code)
					 ((ABS) 'MOVABS)
					 ((FIX) 'FIX)
					 ((FLOAT) 'FLOAT)
					 ((1+) 'INC)
					 ((1-) 'DEC))
				  (cadr code)))
		       ((- -$)
			(cond ((null (cddr code))
			       (tojunary 'MOVNEG (cadr code)))
			      (t (tojbinary (caseq (car code)
						   ((-) 'SUB)
						   ((-$) 'FSUB))
					    (cadr code)
					    (caddr code)))))
		       ((AREF)
			(siftcode
			 (mapcan (function
				  (lambda (op2)
					  (tojaref (cadr code) op2)))
				 (tojhak (caddr code)))))
		       (t (error '|Unknown function - TOJHAK|
				 code
				 'wrng-type-arg))))))

(defun tojunary (opcode op2)
       (siftcode
	(mapcan (function
		 (lambda (p2)
			 (tojun opcode p2)))
		(tojhak op2))))

(defun tojun (opcode place)
       (list (list 'TEMP
		   (cadr place)
		   (cond ((eq (car place) 'RT) 1) (t 0))
		   opcode
		   place)))

(defun wtabarf (loser)
       (error '|Barf!| loser 'wrng-type-arg))

(defun move (place)
       ((lambda (p)
		(list 'TEMP
		      (+ (cadr p) 1)
		      (max (caddr p) 1)
		      'MOV
		      p))
	(cond ((= (caddr place) 2)
	       (regify place 'RTA))
	      (t place))))

(defun regify (place reg)
       (caseq (car place)
	      ((RT) ((lambda (p1 p2)
			     ((lambda (p1a p2a)
				      (or (eq p1 p1a)
					  (eq p2 p2a)
					  (wtabarf place))
				      (cond ((and (eq p1 p1a)
						  (eq p2 p2a))
					     (cons reg (cdr place)))
					    ((null p2)
					     (list reg
						   (cadr place)
						   (caddr place)
						   (cadddr place)
						   p1a))
					    (t (list reg
						     (cadr place)
						     (caddr place)
						     (cadddr place)
						     p1a
						     p2a))))
			      (regify p1 reg)
			      (and p2 (regify p2 reg))))
		     (car (cddddr place))
		     (cadr (cddddr place))))
	      ((RTREF)
	       ((lambda (p)
			(cond ((eq p (car (cddddr place))) place)
			      (t (list (car place)
				       (cadr place)
				       (caddr place)
				       (cadddr place)
				       p))))
		(regify (car (cddddr place)) reg)))
	      ((RTA RTB TEMP VAR REGREF) place)
	      (t (wtabarf place))))

(defun tojbinary (opcode op1 op2)
       (siftcode
	(mapcan (function
		 (lambda (p1)
			 (mapcan (function
				  (lambda (p2)
					  (tojbin opcode p1 p2
						  (+ (cadr p1) (cadr p2)))))
				 (tojhak op2))))
		(tojhak op1))))

;;; RT < RTREF < TEMP < VAR < REGREF

(defun tojbin (opcode p1 p2 overhead)
       (caseq (car p1)
	      ((RT)
	       (caseq (car p2)
		      ((RT)
		       (caseq (caddr p2)
			      ((0 1 2)
			       (list (list 'TEMP overhead 3 opcode
					   (regify p1 'RTB)
					   (regify p2 'RTA))))
			      ((3)
			       (caseq (caddr p1)
				      ((0 1 2)
				       (list (list 'TEMP overhead 3
						   (converse opcode)
						   (regify p2 'RTB)
						   (regify p1 'RTA))))
				      ((3)
				       (list (list 'TEMP (+ overhead 1) 3 opcode
						   (move (regify p1 'RTA))
						   (regify p2 'RTA))))
				      (t (wtabarf p2))))
			      (t (wtabarf p1))))
		      ((RTREF)
		       (caseq (caddr p1)
			      ((0 1 2)
			       (list (list 'TEMP overhead 3 (converse opcode)
					   (regify p2 'RTB)
					   (regify p1 'RTA))))
			      ((3)
			       (caseq (caddr p2)
				      ((0 1)
				       (list (list 'TEMP overhead 3 opcode
						   (regify p1 'RTA)
						   (regify p2 'RTB))))
				      ((2)
				       (list (list 'RT overhead 3 opcode
						   (regify p1 'RTB)
						   (regify p2 'RTA))
					     (list 'TEMP (+ overhead 1) 2 opcode
						   (move (regify p1 'RTA))
						   (regify p2 'RTA))))
				      ((3)
				       (list (list 'RT (+ overhead 1) 3 opcode
						   (move p1)
						   p2)))
				      (t (wtabarf p2))))
			      (t (wtabarf p1))))
		      ((TEMP)
		       (list (list 'TEMP overhead
				   (max (caddr p1) 1)
				   (converse opcode)
				   p2 p1)))
		      ((VAR REGREF)
		       (list (list 'TEMP overhead
				   (max (caddr p1) 2)
				   (converse opcode)
				   p2
				   (regify p1 'RTA))
			     (list 'RT overhead
				   (max (caddr p1) 1)
				   (converse opcode)
				   p2 p1)))
		      (t (wtabarf p2))))
	      ((RTREF)
	       (caseq (car p2)
		      ((RT) (tojbin (converse opcode) p2 p1 overhead))
		      ((RTREF)
		       (caseq (caddr p1)
			      ((0 1 2)
			       (list (list 'RT overhead 3 (converse opcode)
					   (regify p2 'RTB)
					   (regify p1 'RTA))))
			      ((3)
			       (caseq (caddr p2)
				      ((0 1 2)
				       (list (list 'RT overhead 3 opcode
						   (regify p1 'RTB)
						   (regify p2 'RTA))))
				      ((3) '())
				      (t (wtabarf p2))))
			      (t (wtabarf p1))))
		      ((TEMP)
		       (list (list 'TEMP overhead (max (caddr p1) 1)
				   (converse opcode)
				   p2 p1)))
		      ((VAR REGREF)
		       (list (list 'RT overhead (max (caddr p1) 1)
				   (converse opcode)
				   p2 p1)))
		      (t (wtabarf p2))))
	      ((TEMP)
	       (caseq (car p2)
		      ((RT RTREF) (tojbin (converse opcode) p2 p1 overhead))
		      ((TEMP VAR REGREF)
		       (list (list 'TEMP overhead 0 opcode p1 p2)))
		      (t (wtabarf p2))))
	      ((VAR)
	       (caseq (car p2)
		      ((RT RTREF TEMP) (tojbin (converse opcode) p2 p1 overhead))
		      ((VAR REGREF)
		       (list (list 'RT overhead 0 opcode p1 p2)))
		      (t (wtabarf p2))))
	      ((REGREF)
	       (caseq (car p2)
		      ((RT RTREF TEMP VAR)
		       (tojbin (converse opcode) p2 p1 overhead))
		      ((REGREF)
		       (list (list 'RT overhead 0 opcode p1 p2)))
		      (t (wtabarf p2))))
	      (t (wtabarf p1))))

(declare (special *sift-header* *sift-list* *sfc* *sfp*))

(setq *sfp* t)

(setq *sfc* 0)

(defun siftcode (*sift-list*)
       (do ((height -1 (+ height 1))
	    (result '() (siftmerge result (siftprefix height)))
	    (*sift-header* (list nil)))
	   ((null *sift-list*) result)))

(defun siftprefix (height)
       (cond ((null *sift-list*) '())
	     ((< height 1)
	      (rplacd (prog2 nil *sift-list*
			     (setq *sift-list* (cdr *sift-list*)))
		      nil))
	     (t (siftmerge (siftprefix (- height 1))
			   (siftprefix (- height 1))))))

(defun siftmerge (x y)
       (prog (r)
	     (setq r *sift-header*)
	mergeloop
	     (cond ((null x) (rplacd r y) (return (cdr *sift-header*)))
		   ((null y) (rplacd r x) (return (cdr *sift-header*)))
		   (t ((lambda (cx cy)
			       (cond ((< cx cy) (go yflush))
				     ((> cx cy) (go xflush))
				     ((eq (caar x) (caar y))
				      (cond ((and (= (cadar x) (cadar y))
						  (= (caddar x) (caddar y)))
					     (go yflush))
					    ((< (caddar x) (caddar y))
					     (go xkeep))
					    (t (go ykeep))))
				     ((memq (caar y)
					    (memq (caar x)
						  '(RT RTREF TEMP VAR REGREF)))
				      (cond ((and (= (cadar x) (cadar y))
						  (= (caddar x) (caddar y)))
					     (go xflush))
					    (t (go xkeep))))
				     (t (cond ((and (= (cadar x) (cadar y))
						    (= (caddar x) (caddar y)))
					       (go yflush))
					      (t (go ykeep))))))
		       (costimate (car x))
		       (costimate (car y)))))
	xkeep
	     (rplacd r (setq r x))
	     (setq x (cdr x))
	     (go mergeloop)
	xflush
	     (or *sfp* (go xkeep))
	     (setq *sfc* (+ *sfc* 1))
	     (setq x (cdr x))
	     (go mergeloop)
	ykeep
	     (rplacd r (setq r y))
	     (setq y (cdr y))
	     (go mergeloop)
	yflush
	     (or *sfp* (go ykeep))
	     (setq *sfc* (+ *sfc* 1))
	     (setq y (cdr y))
	     (go mergeloop)))

(defun costimate (p)
       (+ (cadr p)
	  (caseq (caddr p)
		 ((0) 0)
		 ((1 2) 1)
		 ((3) 2)
		 (t (wtabarf p)))
	  (caseq (car p)
		 ((RT RTREF) 1)
		 ((TEMP VAR REGREF) 0)
		 (t (wtabarf p)))))

(defun tojaref (base place)
       (caseq (car place)
	      ((RT)
	       (list (list 'RTREF (cadr place) (max (caddr place) 1) base
			   place)
		     (list 'REGREF (+ (cadr place) 1) (max (caddr place) 1) base
			   (move place))))
	      ((RTREF)
	       (list (list 'REGREF (+ (cadr place) 1) (max (caddr place) 1) base
			   (move place))))
	      ((REGREF VAR)
	       (list (list 'REGREF (+ (cadr place) 1) 0 base
			   (move place))))
	      ((TEMP)
	       (list (list 'REGREF (cadr place) 0 base place)))
	      (t (wtabarf place))))

;;; Trivial test code generator
;;; Returns the pair (valloc . code)

(defun gencode (tree)
       (cond ((atom tree) (cons tree '()))
	     (t ((lambda (op1 op2)
			 (gencode1 tree
				   op1
				   op2
				   (gencode op1)
				   (and op2 (gencode op2))))
		 (car (cddddr tree))
		 (cadr (cddddr tree))))))

(declare (special *tempnum*))

(setq *tempnum* 7)

(defun gencode1 (tree op1 op2 code1 code2)
       (caseq (car tree)
	      ((RT RTA RTB TEMP VAR)
	       ((lambda (resultloc)
			(cons resultloc
			      (cond ((memq (cadddr tree) '(CONSTANT VARIABLE))
				     (cdr code1))
				    ((null op2)
				     (append (cdr code1)
					     (list (list (cadddr tree)
							 resultloc
							 (car code1)))))
				    (t (gentop tree
					       op1
					       op2
					       code1
					       code2
					       resultloc)))))
		(caseq (car tree)
		       ((RT) 'RTA)
		       ((RTA RTB) (car tree))
		       ((VAR) (caseq (cadddr tree)
				     ((CONSTANT) (list '? (car code1)))
				     ((VARIABLE) (car code1))
				     (t ???)))
		       ((TEMP)
			(cond ((eq (car op1) 'TEMP) (car code1))
			      ((eq (car op2) 'TEMP) (car code2))
			      (t (list '% (setq *tempnum* (+ *tempnum* 1))))))
		       (t (wtabarf tree)))))
	      ((RTREF REGREF)
	       (cons (list (cadddr tree)
			   (car code1)
			   (list 'S))
		     (cdr code1)))))

(defun gentop (tree op1 op2 code1 code2 resultloc)
       (append (cond ((and (memq (car op1) '(RT RTREF))
			   (memq (car op2) '(VAR TEMP REGREF)))
		      (append (cdr code2) (cdr code1)))
		     (t (append (cdr code1) (cdr code2))))
	       (list (cond ((or (eq (car code2) 'RTA)
				(eq resultloc (car code2)))
			    (gentop1 (converse (cadddr tree))
				     resultloc
				     code2
				     code1))
			   (t (gentop1 (cadddr tree) resultloc code1 code2))))))

(defun gentop1 (opcode resultloc code1 code2)
       (list opcode
	     (cond ((eq resultloc (car code1)) '<) (t resultloc))
	     (car code1)
	     (car code2)))

(defun test fexpr (x)
       (setq *tempnum* 7)
       (princ-s1lap (cdr (gencode (car (tojhak (car x))))))
       'DONE)